home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol160 / display.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1986-12-16  |  23.4 KB  |  834 lines
  1. 90  WIDTH "scrn:", 80
  2. 95  SCREEN 0,1,0,0
  3. 100  TITLE$ = "Display Program"
  4. 105  TITLE$ = TITLE$ + " ON DISPLAY"
  5. 110  VERSION$ = "Version 3.1"
  6. 115  COPY1$ = "Copyright (c) 1983, 1984, 1985, by:"
  7. 120  COPY2$ = "Melvin O. Duke"
  8. 125  PRICE$ = "$35"
  9. 130  ADDR1$ = "Melvin O. Duke"
  10. 135  ADDR2$ = "P. O. Box 20836"
  11. 140  ADDR3$ = "San Jose, CA  95160"
  12. 145  REM Dimension Statements go here
  13. 150  DIM PA.ID(1000), CH.ID(1000), PERS.NO(400), M.NO(400)
  14. 160  DIM PERS(15), CH(55)
  15. 170  REM Produce the first screen
  16. 175  KEY OFF : CLS
  17. 180  REM Draw the outer double box
  18. 185  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 400
  19. 190  REM Find the title location
  20. 195  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  21. 200  REM Draw the title box
  22. 205  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 600
  23. 210  REM Print the title
  24. 215  LOCATE 4,TITLE.POS : PRINT TITLE$
  25. 220  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  26. 225  REM Draw the Contribution box
  27. 230  R1 = 8 : C1 = 19 : R2 = 17 : C2 = 62 : GOSUB 400
  28. 235  REM Request the Contribution
  29. 240  LOCATE 9,23 : PRINT "If you are using these programs, and"
  30. 245  LOCATE 10,21 : PRINT "finding them of value, your contribution"
  31. 250  LOCATE 11,23 : PRINT "("+PRICE$+" suggested) will be anticipated."
  32. 255  REM Draw the Mailing Label
  33. 260  R1 = 12 : C1 = 28 : R2 = 16 : C2 = 52 : GOSUB 600
  34. 265  REM Print the Name and Address
  35. 270  LOCATE 13,40-INT(LEN(ADDR1$)/2) :  PRINT ADDR1$;
  36. 275  LOCATE 14,40-INT(LEN(ADDR2$)/2) :  PRINT ADDR2$;
  37. 280  LOCATE 15,40-INT(LEN(ADDR3$)/2) :  PRINT ADDR3$;
  38. 285  REM Draw the Copyright box
  39. 290  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 400
  40. 295  REM Print the Copyright
  41. 300  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  42. 305  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  43. 310  GOTO 740
  44. 400  REM subroutine to print a double box
  45. 405  COLOR 5
  46. 410  FOR I = R1 + 1 TO R2 - 1
  47. 420   LOCATE I, C1 : PRINT CHR$(186);
  48. 430   LOCATE I, C2 : PRINT CHR$(186);
  49. 440  NEXT I
  50. 450  FOR J = C1 + 1 TO C2 - 1
  51. 460   LOCATE R1, J : PRINT CHR$(205);
  52. 470   LOCATE R2, J : PRINT CHR$(205);
  53. 480  NEXT J
  54. 490   LOCATE R1, C1 : PRINT CHR$(201);
  55. 500   LOCATE R1, C2 : PRINT CHR$(187);
  56. 510   LOCATE R2, C1 : PRINT CHR$(200);
  57. 520   LOCATE R2, C2 : PRINT CHR$(188);
  58. 525  COLOR 7
  59. 530  RETURN
  60. 600  REM subroutine to print a single box
  61. 605  COLOR 3
  62. 610  FOR I = R1 + 1 TO R2 - 1
  63. 620   LOCATE I, C1 : PRINT CHR$(179);
  64. 630   LOCATE I, C2 : PRINT CHR$(179);
  65. 640  NEXT I
  66. 650  FOR J = C1 + 1 TO C2 - 1
  67. 660   LOCATE R1, J : PRINT CHR$(196);
  68. 670   LOCATE R2, J : PRINT CHR$(196);
  69. 680  NEXT J
  70. 690   LOCATE R1, C1 : PRINT CHR$(218);
  71. 700   LOCATE R1, C2 : PRINT CHR$(191);
  72. 710   LOCATE R2, C1 : PRINT CHR$(192);
  73. 720   LOCATE R2, C2 : PRINT CHR$(217);
  74. 725  COLOR 7
  75. 730  RETURN
  76. 740  REM ask user to press a key to continue
  77. 750  LOCATE 25,1
  78. 760  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  79. 770  K$ = INKEY$ : IF K$ = "" THEN 770
  80. 780  CLS
  81. 840  CLS
  82. 850  GOTO 2450
  83. 1000  REM Display Program.
  84. 1010  REM By:  Melvin O. Duke.  Last Updated:  01 August 1985.
  85. 1020  REM Draw the form on the display
  86. 1030  R1= 1 : C1= 1 : R2=21 : C2=79: GOSUB 400 'Double box
  87. 1040  R1= 3 : C1= 1 : R2= 3 : C2=79: GOSUB 2170 'Horizontal Double
  88. 1050  LOCATE 2,3 : PRINT "Pedigree Chart for:"
  89. 1060  LOCATE 4,68 : COLOR 1 : PRINT "Birthdate:" : COLOR 7
  90. 1070  LOCATE 12, 3 : I = 1 : GOSUB 1470
  91. 1080  LOCATE  8,11 : COLOR 3 : PRINT CHR$(218)+CHR$(196);
  92. 1090  LOCATE  9,11 : PRINT CHR$(179);
  93. 1100  LOCATE 10,11 : PRINT CHR$(179);
  94. 1110  LOCATE 11,11 : PRINT CHR$(179);
  95. 1120  LOCATE  8,13 : I = 2 : GOSUB 1510
  96. 1130  LOCATE 16,11 : COLOR 3 : PRINT CHR$(192)+CHR$(196);
  97. 1140  LOCATE 13,11 : PRINT CHR$(179);
  98. 1150  LOCATE 14,11 : PRINT CHR$(179);
  99. 1160  LOCATE 15,11 : PRINT CHR$(179);
  100. 1170  LOCATE 16,13 : I = 3 : GOSUB 1510
  101. 1180  LOCATE  6,21 : COLOR 3 : PRINT CHR$(218)+CHR$(196);
  102. 1190  LOCATE  7,21 : PRINT CHR$(179);
  103. 1200  LOCATE  6,23 : I = 4 : GOSUB 1540
  104. 1210  LOCATE 10,21 : COLOR 3 : PRINT CHR$(192)+CHR$(196);
  105. 1220  LOCATE  9,21 : PRINT CHR$(179);
  106. 1230  LOCATE 10,23 : I = 5 : GOSUB 1540
  107. 1240  LOCATE 14,21 : COLOR 3 : PRINT CHR$(218)+CHR$(196);
  108. 1250  LOCATE 15,21 : PRINT CHR$(179);
  109. 1260  LOCATE 14,23 : I = 6 : GOSUB 1540
  110. 1270  LOCATE 18,21 : COLOR 3 : PRINT CHR$(192)+CHR$(196);
  111. 1280  LOCATE 17,21 : PRINT CHR$(179);
  112. 1290  LOCATE 18,23 : I = 7 : GOSUB 1540
  113. 1300  LOCATE  5,31 : COLOR 3 : PRINT CHR$(218)+CHR$(196);
  114. 1310  LOCATE  5,33 : I = 8 : GOSUB 1570
  115. 1320  LOCATE  7,31 : COLOR 3 : PRINT CHR$(192)+CHR$(196);
  116. 1330  LOCATE  7,33 : I = 9 : GOSUB 1570
  117. 1340  LOCATE  9,31 : COLOR 3 : PRINT CHR$(218)+CHR$(196);
  118. 1350  LOCATE  9,33 : I = 10 : GOSUB 1570
  119. 1360  LOCATE 11,31 : COLOR 3 : PRINT CHR$(192)+CHR$(196);
  120. 1370  LOCATE 11,33 : I = 11 : GOSUB 1570
  121. 1380  LOCATE 13,31 : COLOR 3 : PRINT CHR$(218)+CHR$(196);
  122. 1390  LOCATE 13,33 : I = 12 : GOSUB 1570
  123. 1400  LOCATE 15,31 : COLOR 3 : PRINT CHR$(192)+CHR$(196);
  124. 1410  LOCATE 15,33 : I = 13 : GOSUB 1570
  125. 1420  LOCATE 17,31 : COLOR 3 : PRINT CHR$(218)+CHR$(196);
  126. 1430  LOCATE 17,33 : I = 14 : GOSUB 1570
  127. 1440  LOCATE 19,31 : COLOR 3 : PRINT CHR$(192)+CHR$(196);
  128. 1450  LOCATE 19,33 : I = 15 : GOSUB 1570
  129. 1455  COLOR 7,0
  130. 1460  RETURN
  131. 1470  REM Routine to print the lines
  132. 1480  COLOR 0,7 : PRINT RIGHT$(STR$(I),2);
  133. 1490  COLOR 3,0 : PRINT STRING$(62,95);
  134. 1500  RETURN
  135. 1510  COLOR 0,7 : PRINT RIGHT$(STR$(I),2);
  136. 1520  COLOR 3,0 : PRINT STRING$(52,95);
  137. 1530  RETURN
  138. 1540  COLOR 0,7 : PRINT RIGHT$(STR$(I),2);
  139. 1550  COLOR 3,0 : PRINT STRING$(42,95);
  140. 1560  RETURN
  141. 1570  COLOR 0,7 : PRINT RIGHT$(STR$(I),2);
  142. 1580  COLOR 3,0 : PRINT STRING$(32,95); : COLOR 7,0
  143. 1590  RETURN
  144. 1600  REM Draw the Personal Information Chart
  145. 1610  CLS
  146. 1620  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 400  'Double box
  147. 1630  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 2170  'Horizontal double
  148. 1640  LOCATE 2,3 : PRINT "Personal Information for:"
  149. 1650  R1 = 3 : C1 = 40 : R2 = 21 : C2 = 40 : GOSUB 2310  'Vertical Double
  150. 1660  LOCATE 4,3 : COLOR 1 : PRINT "Person:";
  151. 1665  LOCATE 5,3 : COLOR 6 : PRINT "Record-no.:";
  152. 1670  LOCATE 6,3 : PRINT "Surname:";
  153. 1680  LOCATE 7,3 : PRINT "Given-names:";
  154. 1690  LOCATE 8,3 : PRINT "Sex:";
  155. 1700  R1 = 9 : C1 = 1 : R2 =11 : C2 = 40 : GOSUB 2170  'Horizontal Double
  156. 1710  LOCATE 10,3 : COLOR 1 : PRINT "Person's Father:";
  157. 1715  LOCATE 11,3 : COLOR 6 : PRINT "Record-no.:";
  158. 1720  LOCATE 12,3 : PRINT "Surname:";
  159. 1730  LOCATE 13,3 : PRINT "Given-names:";
  160. 1740  LOCATE 14,3 : PRINT "Birth-date:";
  161. 1750  R1 = 15 : C1 = 1 : R2 = 15 : C2 = 40 : GOSUB 2240  'Horizontal Single
  162. 1760  LOCATE 16,3 : COLOR 1 : PRINT "Person's Mother:";
  163. 1765  LOCATE 17,3 : COLOR 6 : PRINT "Record-no.:";
  164. 1770  LOCATE 18,3 : PRINT "Surname:";
  165. 1780  LOCATE 19,3 : PRINT "Given-names:";
  166. 1790  LOCATE 20,3 : PRINT "Birth-date:";
  167. 1800  LOCATE 4,42 : COLOR 1 : PRINT "Person's Vital Statistics:";
  168. 1810  LOCATE 6,42 : COLOR 6 : PRINT "Birth-date:";
  169. 1820  LOCATE 7,42 : PRINT "Birth-city:";
  170. 1830  LOCATE 8,42 : PRINT "Birth-county:";
  171. 1840  LOCATE 9,42 : PRINT "Birth-state:";
  172. 1850  LOCATE 11,42 : PRINT "Death-date:";
  173. 1860  LOCATE 12,42 : PRINT "Death-city:";
  174. 1870  LOCATE 13,42 : PRINT "Death-county:";
  175. 1880  LOCATE 14,42 : PRINT "Death-state:";
  176. 1890  LOCATE 16,42 : PRINT "Burial-date:";
  177. 1900  LOCATE 17,42 : PRINT "Burial-city:";
  178. 1910  LOCATE 18,42 : PRINT "Burial-county:";
  179. 1920  LOCATE 19,42 : PRINT "Burial-state:"; : COLOR 7,0
  180. 1930  RETURN
  181. 1940  REM draw a Family Group Sheet
  182. 1950  CLS
  183. 1960  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 400  'Double box
  184. 1970  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 2170  'Double Horizontal
  185. 1980  LOCATE 2,3 : PRINT "Family Group Record";
  186. 1985  LOCATE 2,64 : PRINT "Marriage:";
  187. 1990  LOCATE 4,3 : COLOR 6 : PRINT "Father:";
  188. 2000  LOCATE 4,56 : PRINT "Birthdate:";
  189. 2010  LOCATE 5,3 : PRINT "Mother:";
  190. 2020  LOCATE 5,56 : PRINT "Birthdate:";
  191. 2030  R1 = 6 : C1 = 1 : R2 = 6 : C2 = 79 : GOSUB 2240  'Single Horizontal
  192. 2040  LOCATE 7,3 : COLOR 6 : PRINT "Marriage Date:";
  193. 2050  LOCATE 7,35 : PRINT "Location:";
  194. 2060  R1 = 8 : C1 = 1 : R2 = 8 : C2 = 79 : GOSUB 2170  'Double Horizontal
  195. 2070  R1 = 8 : C1 = 4 : R2 = 21 : C2 = 4 : GOSUB 2380  'Single Vertical
  196. 2080  R1 = 8 : C1 = 6 : R2 = 21 : C2 = 6 : GOSUB 2380  'Single Vertical
  197. 2090  R1 = 8 : C1 = 40 : R2 = 21 : C2 = 40 : GOSUB 2380  'Single Vertical
  198. 2100  LOCATE 9,2 : COLOR 1 : PRINT "NO";
  199. 2110  LOCATE 9,5 : PRINT "S";
  200. 2120  LOCATE 9,7 : PRINT "Children:";
  201. 2130  LOCATE 9,41 : PRINT "Birthdate:";
  202. 2140  R1 = 8 : C1 = 52 : R2 = 21 : C2 = 52 : GOSUB 2380  'Single Vertical
  203. 2150  LOCATE 9,53 : COLOR 1 : PRINT "Birth Location:"; : COLOR 7
  204. 2160  RETURN
  205. 2170  REM Subroutine to draw a double horizontal line.  Attach to double.
  206. 2175  COLOR 5
  207. 2180  FOR J = C1 + 1 TO C2 - 1
  208. 2190   LOCATE R1,J : PRINT CHR$(205);
  209. 2200  NEXT J
  210. 2210  LOCATE R1,C1 : PRINT CHR$(204);
  211. 2220  LOCATE R1,C2 : PRINT CHR$(185);
  212. 2225  COLOR 7
  213. 2230  RETURN
  214. 2240  REM Subroutine to draw a single horizontal line.  Attach to double.
  215. 2245  COLOR 5
  216. 2250  FOR J = C1 + 1 TO C2 - 1
  217. 2260   LOCATE R1,J : PRINT CHR$(196);
  218. 2270  NEXT J
  219. 2280  LOCATE R1,C1 : PRINT CHR$(199);
  220. 2290  LOCATE R1,C2 : PRINT CHR$(182);
  221. 2295  COLOR 7
  222. 2300  RETURN
  223. 2310  REM Subroutine to draw a double vertical line.  Attach to double.
  224. 2315  COLOR 5
  225. 2320  FOR I = R1 + 1 TO R2 - 1
  226. 2330   LOCATE I,C1 : PRINT CHR$(186);
  227. 2340  NEXT I
  228. 2350  LOCATE R1,C1 : PRINT CHR$(203);
  229. 2360  LOCATE R2,C1 : PRINT CHR$(202);
  230. 2365  COLOR 7
  231. 2370  RETURN
  232. 2380  REM Subroutine to draw a single vertical line.  Attach to double.
  233. 2385  COLOR 5
  234. 2390  FOR I = R1 + 1 TO R2 - 1
  235. 2400   LOCATE I,C1 : PRINT CHR$(179);
  236. 2410  NEXT I
  237. 2420  LOCATE R1,C1 : PRINT CHR$(209);
  238. 2430  LOCATE R2,C1 : PRINT CHR$(207);
  239. 2435  COLOR 7
  240. 2440  RETURN
  241. 2450  REM Program begins here
  242. 2460  REM By:  Melvin O. Duke.
  243. 2470  REM Read the Parent/Child Index
  244. 2480  OPEN "a:pcindex" FOR INPUT AS #1
  245. 2490  LOCATE 4,1 : PRINT "Open the Parent/Child Index";
  246. 2500  INPUT #1, PC.COUNT
  247. 2510  FOR I = 1 TO PC.COUNT
  248. 2520  LOCATE 5,1 : PRINT "Reading Index Record #:";I;
  249. 2530   INPUT #1, PA.ID(I), CH.ID(I)
  250. 2540  NEXT I
  251. 2550  CLOSE #1
  252. 2560  REM Read the Marriage Index
  253. 2570  LOCATE 7,1 : PRINT "Open the Marriage Index";
  254. 2580  OPEN "a:mindex" FOR INPUT AS #2
  255. 2590  INPUT #2, M.COUNT
  256. 2600  FOR I = 1 TO M.COUNT
  257. 2610  LOCATE 8,1 : PRINT "Reading Marriage Index Record #:";I:
  258. 2620   INPUT #2,PERS.NO(I), M.NO(I)
  259. 2630  NEXT I
  260. 2640  CLOSE #2
  261. 2650  REM Open the Persons File
  262. 2660  LOCATE 10,1 : PRINT "Open the Persons File"
  263. 2670  OPEN "a:persfile" AS #1 LEN = 256
  264. 2680  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  265. 2690  REM open the Marriages File
  266. 2700  LOCATE 12,1 : PRINT "Open the Marriage File"
  267. 2710  OPEN "a:marrfile" AS #2 LEN = 128
  268. 2720  FIELD 2, 5 AS M1$, 5 AS M2$, 5 AS M3$, 5 AS M4$, 11 AS M5$, 18 AS M6$, 16 AS M7$, 16 AS M8$, 45 AS M9$
  269. 2730  REM Open the Ordinance File
  270. 2740  LOCATE 14,1 : PRINT "Open the Ordinances File";
  271. 2750  OPEN "a:ordfile" AS #3 LEN = 256
  272. 2760  FIELD 3,5ASO1$,11ASO2$,11ASO3$,11ASO4$,5ASO5$,5ASO6$,11ASO7$,11ASO8$,11ASO9$,11ASO10$,11ASO11$,5ASO12$,11ASO13$,11ASO14$,11ASO15$,11ASO16$,11ASO17$,11ASO18$,11ASO19$,11ASO20$,11ASO21$,11ASO22$,11ASO23$,26ASO24$
  273. 2770  REM Obtain a Person Record from the User
  274. 2780  LOCATE 20,1 : PRINT SPACE$(79);
  275. 2790  LOCATE 20,1 : INPUT "Enter the Record-number of a Person (0 to quit)";PERS(1)
  276. 2800  IF PERS(1) < 0 OR PERS(1) > 500 THEN CLS: GOTO 2770
  277. 2805  IF PERS(1) = 0 THEN 7390
  278. 2810  REM Obtain the information about a person
  279. 2820  GET #1, PERS(1)
  280. 2830  GOSUB 3300  'Extract Personal Information
  281. 2840  GOSUB 1600
  282. 2850  LOCATE 2,30 : COLOR 7 : PRINT T3$ + " " + T2$;
  283. 2854  LOCATE 2,66 : PRINT "Person:";T1
  284. 2855  LOCATE 5,16 : COLOR 2 : PRINT T1
  285. 2860  LOCATE 6,16 : PRINT T2$;
  286. 2870  LOCATE 7,16 : PRINT T3$;
  287. 2880  LOCATE 8,16 : PRINT T4$;
  288. 2890  LOCATE 6,57 : PRINT T8$;
  289. 2900  LOCATE 7,57 : PRINT T9$;
  290. 2910  LOCATE 8,57 : PRINT T10$;
  291. 2920  LOCATE 9,57 : PRINT T11$;
  292. 2930  LOCATE 11,57 : PRINT T12$;
  293. 2940  LOCATE 12,57 : PRINT T13$;
  294. 2950  LOCATE 13,57 : PRINT T14$;
  295. 2960  LOCATE 14,57 : PRINT T15$;
  296. 2970  LOCATE 16,57 : PRINT T16$;
  297. 2980  LOCATE 17,57 : PRINT T17$;
  298. 2990  LOCATE 18,57 : PRINT T18$;
  299. 3000  LOCATE 19,57 : PRINT T19$;
  300. 3010  PERS(2) = T6
  301. 3020  PERS(3) = T7
  302. 3025  COLOR 7
  303. 3030  REM Check if Father is known
  304. 3040  IF PERS(2) = 0 THEN GOSUB 3590 : GOTO 3065
  305. 3050  GET #1, PERS(2)
  306. 3060  GOSUB 3300  'Extract
  307. 3065  LOCATE 11,16 : COLOR 2 : PRINT T1;
  308. 3070  LOCATE 12,16 : PRINT T2$;
  309. 3080  LOCATE 13,16 : PRINT T3$;
  310. 3090  LOCATE 14,16 : PRINT T8$;
  311. 3095  COLOR 7
  312. 3100  REM Check if Mother is known
  313. 3110  IF PERS(3) = 0 THEN GOSUB 3590 : GOTO 3135
  314. 3120  GET #1, PERS(3)
  315. 3130  GOSUB 3300  'Extract
  316. 3135  LOCATE 17,16 : COLOR 2 : PRINT T1;
  317. 3140  LOCATE 18,16 : PRINT T2$;
  318. 3150  LOCATE 19,16 : PRINT T3$;
  319. 3160  LOCATE 20,16 : PRINT T8$;
  320. 3170  COLOR 7,0 : LOCATE 23,1 : PRINT SPACE$(79);
  321. 3180  LOCATE 24,1 : PRINT SPACE$(79);
  322. 3190  LOCATE 24,1 : PRINT "(Possible Actions:  ps, pc, fg, ";
  323. 3191  PRINT "o, ";
  324. 3192  PRINT "p1...pn, m1...mn, q)";
  325. 3200  LOCATE 23,1 : INPUT "Next Action"; REPLY$
  326. 3210  IF REPLY$ = "ps" THEN GOSUB 6080 : GOTO 3170
  327. 3215  IF REPLY$ = "PS" THEN GOSUB 6080 : GOTO 3170
  328. 3220  IF REPLY$ = "sp" THEN GOSUB 6080 : GOTO 3170
  329. 3225  IF REPLY$ = "SP" THEN GOSUB 6080 : GOTO 3170
  330. 3230  IF REPLY$ = "pc" THEN 3800  'Pedigree Chart
  331. 3235  IF REPLY$ = "PC" THEN 3800  'Pedigree Chart
  332. 3240  IF REPLY$ = "fg" THEN 5070  'Family Group
  333. 3245  IF REPLY$ = "FG" THEN 5070  'Family Group
  334. 3250  IF REPLY$ = "o" THEN 6220  'Ordinances
  335. 3255  IF REPLY$ = "O" THEN 6220  'Ordinances
  336. 3260  IF LEFT$(REPLY$,1) = "p" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : CLS : GOTO 2800
  337. 3265  IF LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : CLS : GOTO 2800
  338. 3270  IF LEFT$(REPLY$,1) = "m" THEN 7260
  339. 3275  IF LEFT$(REPLY$,1) = "M" THEN 7260
  340. 3280  IF LEFT$(REPLY$,1) = "q" THEN 7390
  341. 3285  IF LEFT$(REPLY$,1) = "Q" THEN 7390
  342. 3290  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 3170
  343. 3300  REM Routine to Extract Personal Information
  344. 3310  T1 = CVS(F1$)
  345. 3320  T2$ = F2$
  346. 3330  FOR J = 1 TO LEN(F2$) -1
  347. 3340   IF RIGHT$(T2$,1)=" " THEN T2$ = LEFT$(T2$,LEN(T2$)-1) ELSE J = LEN(F2$)-1
  348. 3350  NEXT J
  349. 3360  T3$ = F3$
  350. 3370  FOR J = 1 TO LEN(F3$) -1
  351. 3380   IF RIGHT$(T3$,1)=" " THEN T3$ = LEFT$(T3$,LEN(T3$)-1) ELSE J = LEN(F3$)-1
  352. 3390  NEXT J
  353. 3400  T4$ = F4$
  354. 3410  IF LEFT$(T4$,1) = "M" THEN T4$ = "Male"
  355. 3420  IF LEFT$(T4$,1) = "F" THEN T4$ = "Female"
  356. 3430  T5 = CVS(F5$)
  357. 3440  T6 = CVS(F6$)
  358. 3450  T7 = CVS(F7$)
  359. 3460  T8$ = F8$
  360. 3470  T9$ = F9$
  361. 3471  FOR J = 1 TO LEN(F9$) -1
  362. 3472   IF RIGHT$(T9$,1)=" " THEN T9$ = LEFT$(T9$,LEN(T9$)-1) ELSE J = LEN(F9$)-1
  363. 3473  NEXT J
  364. 3480  T10$ = F10$
  365. 3490  T11$ = F11$
  366. 3491  FOR J = 1 TO LEN(F11$) -1
  367. 3492   IF RIGHT$(T11$,1)=" " THEN T11$ = LEFT$(T11$,LEN(T11$)-1) ELSE J = LEN(F11$)-1
  368. 3493  NEXT J
  369. 3500  T12$ = F12$
  370. 3510  T13$ = F13$
  371. 3520  T14$ = F14$
  372. 3530  T15$ = F15$
  373. 3540  T16$ = F16$
  374. 3550  T17$ = F17$
  375. 3560  T18$ = F18$
  376. 3570  T19$ = F19$
  377. 3580  RETURN
  378. 3590  REM Blank out a Record
  379. 3600  T1 = 0
  380. 3610  T2$ = ""
  381. 3620  T3$ = ""
  382. 3630  T4$ = ""
  383. 3640  T5 = 0
  384. 3650  T6 = 0
  385. 3660  T7 = 0
  386. 3670  T8$ = ""
  387. 3680  T9$ = ""
  388. 3690  T10$ = ""
  389. 3700  T11$ = ""
  390. 3710  T12$ = ""
  391. 3720  T13$ = ""
  392. 3730  T14$ = ""
  393. 3740  T15$ = ""
  394. 3750  T16$ = ""
  395. 3760  T17$ = ""
  396. 3770  T18$ = ""
  397. 3780  T19$ = ""
  398. 3790  RETURN
  399. 3800  REM Routine to Produce a Pedigree Chart
  400. 3810  CLS
  401. 3820  GOSUB 1000 'Draw the Chart
  402. 3830  GET #1, PERS(1)
  403. 3840  GOSUB 3300  'Extract the Person
  404. 3850  LOCATE 2,23 : COLOR 7 : PRINT T3$ + " " + T2$;
  405. 3855  LOCATE 2,66 : PRINT "Person:"; PERS(1);
  406. 3859  THIS.PERS = PERS(1) : GOSUB 7460
  407. 3860  LOCATE 12,6 : COLOR 2 : PRINT VALUE$;
  408. 3870  LOCATE 12,68 : PRINT T8$;
  409. 3880  PERS(2) = T6
  410. 3890  PERS(3) = T7
  411. 3900  REM Get 11
  412. 3910  IF PERS(2) = 0 THEN GOSUB 3590 : GOTO 3960
  413. 3920  GET #1, PERS(2)
  414. 3930  GOSUB 3300  'Extract
  415. 3939  THIS.PERS = PERS(2) : GOSUB 7460
  416. 3940  LOCATE 8,16 : PRINT VALUE$;
  417. 3950  LOCATE 8,68 : PRINT T8$;
  418. 3960  PERS(4) = T6
  419. 3970  PERS(5) = T7
  420. 3980  REM Get 10
  421. 3990  IF PERS(3) = 0 THEN GOSUB 3590 : GOTO 4040
  422. 4000  GET #1, PERS(3)
  423. 4010  GOSUB 3300  'Extract
  424. 4019  THIS.PERS = PERS(3): GOSUB 7460
  425. 4020  LOCATE 16,16 : PRINT VALUE$;
  426. 4030  LOCATE 16,68 : PRINT T8$;
  427. 4040  PERS(6) = T6
  428. 4050  PERS(7) = T7
  429. 4060  REM Get 111
  430. 4070  IF PERS(4) = 0 THEN GOSUB 3590 : GOTO 4120
  431. 4080  GET #1, PERS(4)
  432. 4090  GOSUB 3300  'Extract
  433. 4099  THIS.PERS = PERS(4): GOSUB 7460
  434. 4100  LOCATE 6,26 : PRINT VALUE$;
  435. 4110  LOCATE 6,68 : PRINT T8$;
  436. 4120  PERS(8) = T6
  437. 4130  PERS(9) = T7
  438. 4140  REM Get 110
  439. 4150  IF PERS(5) = 0 THEN GOSUB 3590 : GOTO 4200
  440. 4160  GET #1, PERS(5)
  441. 4170  GOSUB 3300  'Extract
  442. 4179  THIS.PERS = PERS(5): GOSUB 7460
  443. 4180  LOCATE 10,26 : PRINT VALUE$;
  444. 4190  LOCATE 10,68 : PRINT T8$;
  445. 4200  PERS(10) = T6
  446. 4210  PERS(11) = T7
  447. 4220  REM Get 101
  448. 4230  IF PERS(6) = 0 THEN GOSUB 3590 : GOTO 4280
  449. 4240  GET #1, PERS(6)
  450. 4250  GOSUB 3300  'Extract
  451. 4259  THIS.PERS = PERS(6): GOSUB 7460
  452. 4260  LOCATE 14,26 : PRINT VALUE$;
  453. 4270  LOCATE 14,68 : PRINT T8$;
  454. 4280  PERS(12) = T6
  455. 4290  PERS(13) = T7
  456. 4300  REM Get 100
  457. 4310  IF PERS(7) = 0 THEN GOSUB 3590 : GOTO 4360
  458. 4320  GET #1, PERS(7)
  459. 4330  GOSUB 3300  'Extract
  460. 4339  THIS.PERS = PERS(7): GOSUB 7460
  461. 4340  LOCATE 18,26 : PRINT VALUE$;
  462. 4350  LOCATE 18,68 : PRINT T8$;
  463. 4360  PERS(14) = T6
  464. 4370  PERS(15) = T7
  465. 4380  REM Get 1111
  466. 4390  IF PERS(8) = 0 THEN GOSUB 3590 : GOTO 4440
  467. 4400  GET #1, PERS(8)
  468. 4410  GOSUB 3300  'Extract
  469. 4419  THIS.PERS = PERS(8): GOSUB 7460
  470. 4420  LOCATE  5,36 : PRINT VALUE$;
  471. 4430  LOCATE  5,68 : PRINT T8$;
  472. 4440  REM
  473. 4450  REM Get 1110
  474. 4460  IF PERS(9) = 0 THEN GOSUB 3590 : GOTO 4510
  475. 4470  GET #1, PERS(9)
  476. 4480  GOSUB 3300  'Extract
  477. 4489  THIS.PERS = PERS(9): GOSUB 7460
  478. 4490  LOCATE  7,36 : PRINT VALUE$;
  479. 4500  LOCATE  7,68 : PRINT T8$;
  480. 4510  REM
  481. 4520  REM Get 1101
  482. 4530  IF PERS(10) = 0 THEN GOSUB 3590 : GOTO 4580
  483. 4540  GET #1, PERS(10)
  484. 4550  GOSUB 3300  'Extract
  485. 4559  THIS.PERS = PERS(10): GOSUB 7460
  486. 4560  LOCATE  9,36 : PRINT VALUE$;
  487. 4570  LOCATE  9,68 : PRINT T8$;
  488. 4580  REM
  489. 4590  REM Get 1100
  490. 4600  IF PERS(11) = 0 THEN GOSUB 3590 : GOTO 4650
  491. 4610  GET #1, PERS(11)
  492. 4620  GOSUB 3300  'Extract
  493. 4629  THIS.PERS = PERS(11): GOSUB 7460
  494. 4630  LOCATE 11,36 : PRINT VALUE$;
  495. 4640  LOCATE 11,68 : PRINT T8$;
  496. 4650  REM
  497. 4660  REM Get 1011
  498. 4670  IF PERS(12) = 0 THEN GOSUB 3590 : GOTO 4720
  499. 4680  GET #1, PERS(12)
  500. 4690  GOSUB 3300  'Extract
  501. 4699  THIS.PERS = PERS(12): GOSUB 7460
  502. 4700  LOCATE 13,36 : PRINT VALUE$;
  503. 4710  LOCATE 13,68 : PRINT T8$;
  504. 4720  REM
  505. 4730  REM Get 1010
  506. 4740  IF PERS(13) = 0 THEN GOSUB 3590 : GOTO 4790
  507. 4750  GET #1, PERS(13)
  508. 4760  GOSUB 3300  'Extract
  509. 4769  THIS.PERS = PERS(13): GOSUB 7460
  510. 4770  LOCATE 15,36 : PRINT VALUE$;
  511. 4780  LOCATE 15,68 : PRINT T8$;
  512. 4790  REM
  513. 4800  REM Get 1001
  514. 4810  IF PERS(14) = 0 THEN GOSUB 3590 : GOTO 4860
  515. 4820  GET #1, PERS(14)
  516. 4830  GOSUB 3300  'Extract
  517. 4839  THIS.PERS = PERS(14): GOSUB 7460
  518. 4840  LOCATE 17,36 : PRINT VALUE$;
  519. 4850  LOCATE 17,68 : PRINT T8$;
  520. 4860  REM
  521. 4870  REM Get 1000
  522. 4880  IF PERS(15) = 0 THEN GOSUB 3590 : GOTO 4930
  523. 4890  GET #1, PERS(15)
  524. 4900  GOSUB 3300  'Extract
  525. 4909  THIS.PERS = PERS(15): GOSUB 7460
  526. 4910  LOCATE 19,36 : PRINT VALUE$;
  527. 4920  LOCATE 19,68 : PRINT T8$; : COLOR 7
  528. 4930  REM
  529. 4940  LOCATE 23,1 : PRINT SPACE$(79);
  530. 4950  LOCATE 24,1 : PRINT SPACE$(79);
  531. 4960  LOCATE 24,1 : PRINT "(Possible Actions:  ps, pc, fg, l1...ln, p1...pn, m1...mn, q)";
  532. 4970  LOCATE 23,1 : INPUT "Next Action"; REPLY$
  533. 4980  IF REPLY$ = "ps" THEN GOSUB 6080 : GOTO 4940
  534. 4985  IF REPLY$ = "PS" THEN GOSUB 6080 : GOTO 4940
  535. 4990  IF REPLY$ = "sp" THEN GOSUB 6080 : GOTO 4940
  536. 4995  IF REPLY$ = "SP" THEN GOSUB 6080 : GOTO 4940
  537. 5000  IF REPLY$ = "pc" THEN 3800
  538. 5005  IF REPLY$ = "PC" THEN 3800
  539. 5010  IF REPLY$ = "fg" THEN 5070
  540. 5015  IF REPLY$ = "FG" THEN 5070
  541. 5020  IF LEFT$(REPLY$,1) = "l" THEN PERS(1) = PERS(VAL(RIGHT$(REPLY$,LEN(REPLY$)-1))) : GOTO 2810
  542. 5025  IF LEFT$(REPLY$,1) = "L" THEN PERS(1) = PERS(VAL(RIGHT$(REPLY$,LEN(REPLY$)-1))) : GOTO 2810
  543. 5030  IF LEFT$(REPLY$,1) = "p" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : GOTO 2800
  544. 5035  IF LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : GOTO 2800
  545. 5040  IF LEFT$(REPLY$,1) = "m" THEN 7260
  546. 5045  IF LEFT$(REPLY$,1) = "M" THEN 7260
  547. 5050  IF LEFT$(REPLY$,1) = "q" THEN 7390
  548. 5055  IF LEFT$(REPLY$,1) = "Q" THEN 7390
  549. 5060  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 4940
  550. 5070  REM Routine to Produce a Family Group Record
  551. 5080  CLS
  552. 5090  GOSUB 1940  'Draw the form
  553. 5100  REM search the marriage index for the Person's Marriage
  554. 5110  FOUND = 0
  555. 5120  FOR L = 1 TO M.COUNT
  556. 5130   IF PERS(1) > PERS.NO(L) THEN 5190
  557. 5140   IF PERS(1) < PERS.NO(L) THEN L = M.COUNT : GOTO 5190
  558. 5150   REM found a Marriage
  559. 5160   FOUND = 1
  560. 5170   GET #2, M.NO(L)
  561. 5180   L = M.COUNT
  562. 5190  NEXT L
  563. 5200  IF FOUND = 1 THEN 5260
  564. 5210  REM No marriage found
  565. 5220  LOCATE 22,1 : COLOR 7,0 : PRINT "No Marriage Found";
  566. 5230  LOCATE 23,1 : PRINT "Press any key to continue";
  567. 5240  A$ = INKEY$ : IF A$ = "" THEN 5240
  568. 5250  CLS : GOTO 2810
  569. 5260  REM extract Information from the Marriage Record
  570. 5270  TT1 = CVS(M1$)
  571. 5275  IF TT1 < 1 THEN 5210
  572. 5280  TT2 = CVS(M2$)
  573. 5290  TT3 = CVS(M3$)
  574. 5300  TT4 = CVS(M4$)
  575. 5310  TT5$ = M5$
  576. 5320  TT6$ = M6$
  577. 5321  REM Right-trim
  578. 5322  FOR J = 1 TO LEN(M6$) -1
  579. 5323   IF RIGHT$(TT6$,1)=" " THEN TT6$ = LEFT$(TT6$,LEN(TT6$)-1) ELSE J = LEN(M6$)-1
  580. 5324  NEXT J
  581. 5330  TT7$ = M7$
  582. 5340  TT8$ = M8$
  583. 5341  REM Right-trim
  584. 5342  FOR J = 1 TO LEN(M8$) -1
  585. 5343   IF RIGHT$(TT8$,1)=" " THEN TT8$ = LEFT$(TT8$,LEN(TT8$)-1) ELSE J = LEN(M8$)-1
  586. 5344  NEXT J
  587. 5350  TT9$ = M9$
  588. 5360  REM print the Marriage Information
  589. 5365  LOCATE 2,73 : COLOR 7 : PRINT TT1
  590. 5370  LOCATE 7,18 : COLOR 2 : PRINT TT5$
  591. 5375  IF TT6$ = " " AND TT8$ = " " THEN 5390
  592. 5380  LOCATE 7,45 : PRINT LEFT$(TT6$+", "+TT8$,34)
  593. 5390  REM get the Husband's Record
  594. 5400  GET #1, TT2
  595. 5410  GOSUB 3300  'Extract
  596. 5419  THIS.PERS = TT2 : GOSUB 7460
  597. 5420  LOCATE 4,11 : COLOR 2 : PRINT VALUE$;
  598. 5430  LOCATE 4,67 : PRINT T8$;
  599. 5440  REM get the Wife's Record
  600. 5450  GET #1, TT3
  601. 5460  GOSUB 3300  'Extract
  602. 5469  THIS.PERS = TT3 : GOSUB 7460
  603. 5470  LOCATE 5,11 : COLOR 2 : PRINT VALUE$;
  604. 5480  LOCATE 5,67 : PRINT T8$;
  605. 5490  REM now find the children
  606. 5500  CHILD.COUNT = 0
  607. 5510  FOR IC = 1 TO 55
  608. 5520   CH(IC) = 0
  609. 5530  NEXT IC
  610. 5540  REM search the parent/child index
  611. 5550  FOR LL = 1 TO PC.COUNT
  612. 5560   IF TT2 > PA.ID(LL) THEN 5890
  613. 5570   IF TT2 < PA.ID(LL) THEN LL = PC.COUNT : GOTO 5890
  614. 5580   REM found a child
  615. 5590   GET #1, CH.ID(LL)
  616. 5600   GOSUB 3300  'Extract
  617. 5610   REM verify that Mother is the same
  618. 5620   IF TT3 <> T7 THEN 5890
  619. 5630   REM Found a valid child
  620. 5640   CHILD.COUNT = CHILD.COUNT + 1
  621. 5650   SHOW.COUNT = CHILD.COUNT
  622. 5660   IF CHILD.COUNT = 1 THEN 5820
  623. 5670   IF CHILD.COUNT > 11 THEN SHOW.COUNT = CHILD.COUNT - 11
  624. 5680   IF CHILD.COUNT > 22 THEN SHOW.COUNT = CHILD.COUNT - 22
  625. 5690   IF CHILD.COUNT > 33 THEN SHOW.COUNT = CHILD.COUNT - 33
  626. 5700   IF CHILD.COUNT > 44 THEN SHOW.COUNT = CHILD.COUNT - 44
  627. 5710   IF (CHILD.COUNT-1) MOD 11 = 0 THEN 5720 ELSE 5820
  628. 5720   LOCATE 23,1 : PRINT SPACE$(79);
  629. 5730   LOCATE 23,1 : PRINT "Press any key to continue"
  630. 5740   A$ = INKEY$ : IF A$ = "" THEN 5740
  631. 5750   REM blank the previous children
  632. 5760   FOR ROW = 9 TO 20
  633. 5770    LOCATE ROW,2 : PRINT SPACE$(77);
  634. 5780   NEXT ROW
  635. 5790   REM restore the rest of the display
  636. 5800   GOSUB 2070
  637. 5810   LOCATE 23,1 : PRINT SPACE$(79)
  638. 5820   CH(CHILD.COUNT) = CH.ID(LL)
  639. 5830   LOCATE 9+SHOW.COUNT,2 : COLOR 0,7
  640. 5840   PRINT RIGHT$(STR$(CHILD.COUNT),2); : COLOR 2,0
  641. 5850   LOCATE 9+SHOW.COUNT,5 : PRINT LEFT$(F4$,1);  'Sex
  642. 5860   LOCATE 9+SHOW.COUNT,7 : PRINT T2$+", "+T3$;
  643. 5870   LOCATE 9+SHOW.COUNT,41 : PRINT T8$;
  644. 5875   IF T9$ = " " AND T11$ = " " THEN 5885
  645. 5880   LOCATE 9+SHOW.COUNT,53 : PRINT LEFT$(T9$+", "+T11$,26);
  646. 5885   COLOR 7,0
  647. 5890  NEXT LL
  648. 5900  LOCATE 23,1 : PRINT SPACE$(79);
  649. 5910  LOCATE 24,1 : PRINT SPACE$(79);
  650. 5920  LOCATE 24,1 : PRINT "(Possible Actions: ps, f, m, p1...pn, c1...cn, m1...mn, q)";
  651. 5930  LOCATE 23,1 : INPUT "Next Action";REPLY$
  652. 5940  IF REPLY$ = "ps" THEN GOSUB 6080 : GOTO 5900
  653. 5945  IF REPLY$ = "PS" THEN GOSUB 6080 : GOTO 5900
  654. 5950  IF REPLY$ = "sp" THEN GOSUB 6080 : GOTO 5900
  655. 5955  IF REPLY$ = "SP" THEN GOSUB 6080 : GOTO 5900
  656. 5960  IF REPLY$ = "pc" THEN LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 5900
  657. 5965  IF REPLY$ = "PC" THEN LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 5900
  658. 5970  IF REPLY$ = "f" THEN PERS(1) = TT2 : GOTO 2810
  659. 5975  IF REPLY$ = "F" THEN PERS(1) = TT2 : GOTO 2810
  660. 5980  IF REPLY$ = "m" THEN PERS(1) = TT3 : GOTO 2810
  661. 5985  IF REPLY$ = "M" THEN PERS(1) = TT3 : GOTO 2810
  662. 5990  IF LEFT$(REPLY$,1) = "p" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : GOTO 2800
  663. 5995  IF LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : GOTO 2800
  664. 6000  IF LEFT$(REPLY$,1) = "c" THEN 6010
  665. 6005  IF LEFT$(REPLY$,1) = "C" THEN 6010 ELSE 6050
  666. 6010  CHLD = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1))
  667. 6020  IF CHLD < 1 OR CHLD > CHILD.COUNT THEN 6070
  668. 6030  PERS(1) = CH(CHLD)
  669. 6040  GOTO 2810  'for personal
  670. 6050  IF LEFT$(REPLY$,1) = "m" THEN 7260 'marriage
  671. 6055  IF LEFT$(REPLY$,1) = "M" THEN 7260 'marriage
  672. 6060  IF LEFT$(REPLY$,1) = "q" THEN 7390
  673. 6065  IF LEFT$(REPLY$,1) = "Q" THEN 7390
  674. 6070  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 5900
  675. 6080  REM Routine to Print the Screen
  676. 6090  REM Accessed by users 'ps' reply
  677. 6100  FOR ROW = 1 TO 20
  678. 6110   THIS$ = SPACE$(79)
  679. 6120   FOR COL = 1 TO 79
  680. 6130    X = SCREEN(ROW,COL)
  681. 6140    IF X > 125 THEN X = 32
  682. 6150    IF X < 32 THEN X = 32
  683. 6160    MID$(THIS$,COL,1) = CHR$(X)
  684. 6170   NEXT COL
  685. 6180   LPRINT THIS$
  686. 6190  NEXT ROW
  687. 6200  LPRINT CHR$(12);
  688. 6210  RETURN
  689. 6220  REM Routine to Display the Ordinances
  690. 6230  GET #1, PERS(1) : GOSUB 3300
  691. 6240  GET #3, PERS(1)
  692. 6250  SEX$ = LEFT$(T4$,1)
  693. 6260  REM Extract the Ordinance Information
  694. 6270  U1 = CVS(O1$)
  695. 6271  REM Blank Ordinances of no Ordinance Record Present
  696. 6272  IF U1 = 0 THEN GOSUB 8200 : GOTO 6510
  697. 6280  U2$ = O2$
  698. 6290  U3$ = O3$
  699. 6300  U4$ = O4$
  700. 6310  U5  = CVS(O5$)
  701. 6320  U6  = CVS(O6$)
  702. 6330  U7$ = O7$
  703. 6340  U8$ = O8$
  704. 6350  U9$ = O9$
  705. 6360  U10$ = O10$
  706. 6370  U11$ = O11$
  707. 6380  U12  = CVS(O12$)
  708. 6390  U13$ = O13$
  709. 6400  U14$ = O14$
  710. 6410  U15$ = O15$
  711. 6420  U16$ = O16$
  712. 6430  U17$ = O17$
  713. 6440  U18$ = O18$
  714. 6450  U19$ = O19$
  715. 6460  U20$ = O20$
  716. 6470  U21$ = O21$
  717. 6480  U22$ = O22$
  718. 6490  U23$ = O23$
  719. 6500  U24$ = O24$
  720. 6510  CLS
  721. 6520  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 400  'Double Box
  722. 6530  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 2170  'Horizontal Double
  723. 6540  R1 = 19 : C1 = 1 : R2 = 19 : C2 = 79 : GOSUB 2170  'Horizontal Double
  724. 6550  LOCATE 2,3 : PRINT "Ordinance Information for:";
  725. 6560  LOCATE 4,7 : COLOR 1 : PRINT "Personal Record"; : COLOR 6
  726. 6570  LOCATE 5,3 : PRINT "Christening:";
  727. 6580  LOCATE 6,3 : PRINT "Blessing:";
  728. 6590  LOCATE 7,3 : PRINT "Sealed to Parents:";
  729. 6600  LOCATE 8,5 : PRINT "Father's Id:";
  730. 6610  LOCATE 9,6 : PRINT "Name:";
  731. 6620  LOCATE 10,5 : PRINT "Mother's Id:";
  732. 6630  LOCATE 11,6 : PRINT "Name:";
  733. 6640  LOCATE 12,3 : PRINT "Baptism:";
  734. 6650  LOCATE 13,3 : PRINT "Confirmation:";
  735. 6660  LOCATE 14,3 : PRINT "Patriarchical Blessing:";
  736. 6670  LOCATE 15,3 : PRINT "Endowment:";
  737. 6674  REM Test for male.  Skip if male.
  738. 6675  IF SEX$ = "M" THEN 6710
  739. 6680  LOCATE 16,3 : PRINT "Sealed to Husband:";
  740. 6690  LOCATE 17,5 : PRINT "Husband's Id.:";
  741. 6700  LOCATE 18,6 : PRINT "Name:";
  742. 6710  REM Test for Male.  Skip if not
  743. 6720  IF SEX$ <> "M" THEN 6860
  744. 6730  R1 = 3 : R2 = 19 : C1 = 40 : C2 = 40 : GOSUB 2310  "Vertical Double
  745. 6740  LOCATE 4,46 : COLOR 1 : PRINT "Priesthood Record"; : COLOR 6
  746. 6750  LOCATE 5,42 : PRINT "Aaronic Priesthood:";
  747. 6760  LOCATE 6,44 : PRINT "Deacon:";
  748. 6770  LOCATE 7,44 : PRINT "Teacher:";
  749. 6780  LOCATE 8,44 : PRINT "Priest:";
  750. 6790  LOCATE 10,42 : PRINT "Melchizedek Priesthood:";
  751. 6800  LOCATE 11,44 : PRINT "Elder:";
  752. 6810  LOCATE 12,44 : PRINT "Seventy:";
  753. 6820  LOCATE 13,44 : PRINT "High Priest:";
  754. 6830  LOCATE 15,42 : PRINT "Bishop:";
  755. 6840  LOCATE 16,42 : PRINT "Patriarch:";
  756. 6850  LOCATE 17,42 : PRINT "Apostle:";
  757. 6860  LOCATE 20,3  : PRINT "Occupation:";
  758. 6870  REM Print the Information Currently Present
  759. 6880  LOCATE 2,30 : COLOR 7 : PRINT T3$ + " " + T2$;
  760. 6890  LOCATE 2,66 : PRINT "Person:";T1;
  761. 6900  LOCATE 5,28 : COLOR 2 : PRINT U2$;
  762. 6910  LOCATE 6,28 : PRINT U3$;
  763. 6920  LOCATE 7,28 : PRINT U4$;
  764. 6940  LOCATE 8,18 : PRINT U5;
  765. 6950  IF U5 = 0 THEN 6980
  766. 6960  GET #1, U5 : GOSUB 3300  'Extract Father Information
  767. 6970  LOCATE 9,12 : PRINT T3$ + " " + T2$;
  768. 6980  LOCATE 10,18 : PRINT U6;
  769. 6990  IF U6 = 0 THEN 7020
  770. 7000  GET #1, U6 : GOSUB 3300  'Extract Mother Information
  771. 7010  LOCATE 11,12 : PRINT T3$ + " " + T2$;
  772. 7020  LOCATE 12,28 : PRINT U7$;
  773. 7030  LOCATE 13,28 : PRINT U8$;
  774. 7040  LOCATE 14,28 : PRINT U9$;
  775. 7050  LOCATE 15,28 : PRINT U10$;
  776. 7054  REM Test for male.  Skip if male.
  777. 7055  IF SEX$ = "M" THEN 7110
  778. 7060  LOCATE 16,28 : PRINT U11$;
  779. 7070  LOCATE 17,19 : PRINT U12;
  780. 7080  IF U12 = 0 THEN 7110
  781. 7090  GET #1, U12 : GOSUB 3300  'Extract Spouse Information
  782. 7100  LOCATE 18,12 : PRINT T3$ + " " + T2$;
  783. 7110  REM Test for Male.  Bypass if not.
  784. 7120  IF SEX$ <> "M" THEN 7240
  785. 7130  LOCATE 5,67 : PRINT U13$;
  786. 7140  LOCATE 6,67 : PRINT U14$;
  787. 7150  LOCATE 7,67 : PRINT U15$;
  788. 7160  LOCATE 8,67 : PRINT U16$;
  789. 7170  LOCATE 10,67 : PRINT U17$;
  790. 7180  LOCATE 11,67 : PRINT U18$;
  791. 7190  LOCATE 12,67 : PRINT U19$;
  792. 7200  LOCATE 13,67 : PRINT U20$;
  793. 7210  LOCATE 14,67 : PRINT U21$;
  794. 7220  LOCATE 15,67 : PRINT U22$;
  795. 7230  LOCATE 16,67 : PRINT U23$;
  796. 7240  LOCATE 20,15 : PRINT U24$;
  797. 7250  GOTO 3170  'For User Action
  798. 7260  REM Marriage was requested by Number
  799. 7270  MARRIAGE = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1))
  800. 7280  CLS
  801. 7290  IF MARRIAGE > 0 AND MARRIAGE <= 200 THEN 7360
  802. 7300  LOCATE 22,1 : PRINT SPACE$(79);
  803. 7310  LOCATE 22,1 : PRINT "Invalid Marriage Number";
  804. 7320  LOCATE 23,1 : PRINT SPACE$(79);
  805. 7330  LOCATE 23,1 : PRINT "Press any key to continue."
  806. 7340  A$ = INKEY$ : IF A$ = "" THEN 7340
  807. 7350  GOTO 2810
  808. 7360  GOSUB 1940  'Print the form
  809. 7370  GET #2, MARRIAGE
  810. 7380  GOTO 5260
  811. 7390  REM Wrapup
  812. 7400  CLOSE #1
  813. 7410  CLOSE #2
  814. 7420  CLOSE #3
  815. 7430  CLS : LOCATE 21,1 : COLOR 7,0
  816. 7440  PRINT "End of Program"
  817. 7450  RUN "a:menu"
  818. 7460  REM Routine to Convert a number to a string.  This.pers is input
  819. 7470  REM value$ is output, with record number and persons name.
  820. 7480  VALUE$ = STR$(THIS.PERS)
  821. 7490  WIDE = LEN(VALUE$)
  822. 7500  VALUE$ = RIGHT$(VALUE$,WIDE-1)
  823. 7510  VALUE$ = "("+VALUE$+") "+T2$+", "+T3$
  824. 7520  RETURN
  825. 8200  REM Blank Ordinances if No Ord Record
  826. 8210  U2$  = "" : U3$  = "" : U4$  = ""
  827. 8220  U5   = 0  : U6   = 0  : U12  = 0
  828. 8230  U7$  = "" : U8$  = "" : U9$  = "" : U10$ = ""
  829. 8240  U11$ = "" : U13$ = "" : U14$ = "" : U15$ = ""
  830. 8250  U16$ = "" : U17$ = "" : U18$ = "" : U19$ = ""
  831. 8260  U20$ = "" : U21$ = "" : U22$ = "" : U23$ = ""
  832. 8270  U24$ = ""
  833. 8280  RETURN
  834.